home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / defmacro.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  9.3 KB  |  272 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    defmacro.lsp
  21. ;;;;
  22. ;;;;         defines SI:DEFMACRO*, the defmacro preprocessor
  23.  
  24.  
  25. (in-package 'lisp)
  26. (export '(&whole &environment &body))
  27.  
  28.  
  29. (in-package 'system)
  30.  
  31.  
  32. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  33.  
  34.  
  35. ;;; valid lambda-list to DEFMACRO is:
  36. ;;;
  37. ;;;    ( [ &whole sym ]
  38. ;;;      [ &environment sym ]
  39. ;;;      { v }*
  40. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  41. ;;;      {  [ { &rest | &body } v ]
  42. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  43. ;;;            [ &allow-other-keys ]]
  44. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  45. ;;;      |  . sym }
  46. ;;;     )
  47. ;;;
  48. ;;; where v is short for { defmacro-lambda-list | sym }.
  49. ;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case
  50. ;;; (DEFMACRO <name> <symbol> ... ) is equivalent to
  51. ;;; (DEFMACRO <name> (&REST <symbol>) ...).
  52. ;;; Defamcro-lambda-list is defined as:
  53. ;;;
  54. ;;;    ( { v }*
  55. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  56. ;;;      {  [ { &rest | &body } v ]
  57. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  58. ;;;            [ &allow-other-keys ]]
  59. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  60. ;;;      |  . sym }
  61. ;;;     )
  62.  
  63. ;; defvar is not yet available.
  64. (mapc '*make-special '(*dl* *key-check* *arg-check*))
  65.  
  66.  
  67. (defun get-&environment(vl &aux env)
  68.   (let ((env-m
  69.      (and (listp vl)
  70.           (do ((tail vl (cdr tail)))
  71.           ((not (consp tail)) nil)
  72.         (when (eq '&environment (car tail))
  73.           (return tail))))))
  74.     (cond (env-m
  75.         (setq env (cadr env-m))
  76.         (setq vl (append (ldiff vl env-m) (cddr env-m)))))
  77.     (values vl env)))
  78.  
  79.  
  80.  
  81. (defun si:defmacro* (name vl body
  82.                           &aux *dl* (*key-check* nil)
  83.                                (*arg-check* nil)
  84.                                doc decls whole ppn (env nil) envp)
  85.   (cond ((listp vl))
  86.         ((symbolp vl) (setq vl (list '&rest vl)))
  87.         (t (error "The defmacro-lambda-list ~s is not a list." vl)))
  88.   (multiple-value-setq (doc decls body) (find-doc body nil))
  89.   (cond ((and (listp vl) (eq (car vl) '&whole))
  90.          (setq whole (cadr vl)) (setq vl (cddr vl)))
  91.         (t (setq whole (gensym))))
  92.   (multiple-value-setq (vl env)
  93.                (get-&environment vl))
  94.   (setq envp env)
  95.   (or env (setq env (gensym)))
  96.   (setq *dl* `(&aux ,env ,whole))
  97.   (setq ppn (dm-vl vl whole t))
  98.   (dolist (kc *key-check*)
  99.           (push `(unless (getf ,(car kc) :allow-other-keys)
  100.                          (do ((vl ,(car kc) (cddr vl)))
  101.                              ((endp vl))
  102.                              (unless (member (car vl) ',(cdr kc))
  103.                                      (dm-key-not-allowed (car vl))
  104.                                      )))
  105.                 body))
  106.   (dolist (ac *arg-check*)
  107.           (push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac)))
  108.                          (dm-too-many-arguments)) body))
  109.   (unless envp (push `(declare (ignore ,env)) body))
  110.   (list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body)))
  111.   )
  112.  
  113. (defun dm-vl (vl whole top)
  114.   (do ((optionalp nil) (restp nil) (keyp nil)
  115.        (allow-other-keys-p nil) (auxp nil)
  116.        (rest nil) (allow-other-keys nil) (keys nil) (no-check nil)
  117.        (n (if top 1 0)) (ppn nil)
  118.        )
  119.       ((not (consp vl))
  120.        (when vl
  121.          (when restp (dm-bad-key '&rest))
  122.          (push (list vl (dm-nth-cdr n whole)) *dl*)
  123.          (setq no-check t))
  124.        (when (and rest (not allow-other-keys))
  125.          (push (cons rest keys) *key-check*))
  126.        (unless no-check (push (cons whole n) *arg-check*))
  127.        ppn
  128.        )
  129.     (let ((v (car vl)))
  130.       (cond
  131.        ((eq v '&optional)
  132.         (when optionalp (dm-bad-key '&optional))
  133.         (setq optionalp t)
  134.         (pop vl))
  135.        ((or (eq v '&rest) (eq v '&body))
  136.         (when restp (dm-bad-key v))
  137.         (dm-v (cadr vl) (dm-nth-cdr n whole))
  138.         (setq restp t optionalp t no-check t)
  139.         (setq vl (cddr vl))
  140.         (when (eq v '&body) (setq ppn (if top (1- n) n))))
  141.        ((eq v '&key)
  142.         (when keyp (dm-bad-key '&key))
  143.         (setq rest (gensym))
  144.         (push (list rest (dm-nth-cdr n whole)) *dl*)
  145.         (setq keyp t restp t optionalp t no-check t)
  146.         (pop vl))
  147.        ((eq v '&allow-other-keys)
  148.         (when (or (not keyp) allow-other-keys-p)
  149.               (dm-bad-key '&allow-other-keys))
  150.         (setq allow-other-keys-p t)
  151.         (setq allow-other-keys t)
  152.         (pop vl))
  153.        ((eq v '&aux)
  154.         (when auxp (dm-bad-key '&aux))
  155.         (setq auxp t allow-other-keys-p t keyp t restp t optionalp t)
  156.         (pop vl))
  157.        (auxp
  158.         (let (x (init nil))
  159.              (cond ((symbolp v) (setq x v))
  160.                    (t (setq x (car v))
  161.                       (unless (endp (cdr v)) (setq init (cadr v)))))
  162.              (dm-v x init))
  163.         (pop vl))
  164.        (keyp
  165.         (let ((temp (gensym)) x k (init nil) (sv nil))
  166.              (cond ((symbolp v) (setq x v k (intern (string v) 'keyword)))
  167.                    (t (if (symbolp (car v))
  168.                           (setq x (car v)
  169.                                 k (intern (string (car v)) 'keyword))
  170.                           (setq x (cadar v) k (caar v)))
  171.                       (unless (endp (cdr v))
  172.                               (setq init (cadr v))
  173.                               (unless (endp (cddr v))
  174.                                       (setq sv (caddr v))))))
  175.              (dm-v temp `(getf ,rest ,k 'failed))
  176.              (dm-v x `(if (eq ,temp 'failed) ,init ,temp))
  177.              (when sv (dm-v sv `(not (eq ,temp 'failed))))
  178.              (push k keys))
  179.         (pop vl))
  180.        (optionalp
  181.         (let (x (init nil) (sv nil))
  182.              (cond ((symbolp v) (setq x v))
  183.                    (t (setq x (car v))
  184.                       (unless (endp (cdr v))
  185.                               (setq init (cadr v))
  186.                               (unless (endp (cddr v))
  187.                                       (setq sv (caddr v))))))
  188.              (dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init))
  189.              (when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole))))))
  190.         (incf n)
  191.         (pop vl)
  192.         )
  193.        (t (dm-v v `(if ,(dm-nth-cdr n whole)
  194.                        ,(dm-nth n whole)
  195.                        (dm-too-few-arguments)))
  196.           (incf n)
  197.           (pop vl))
  198.        ))))
  199.  
  200. (defun dm-v (v init)
  201.        (if (symbolp v)
  202.            (push (if init (list v init) v) *dl*)
  203.            (let ((temp (gensym)))
  204.                 (push (if init (list temp init) temp) *dl*)
  205.                 (dm-vl v temp nil))))
  206.  
  207. (defun dm-nth (n v)
  208.   (multiple-value-bind (q r) (floor n 4)
  209.      (dotimes (i q) (setq v (list 'cddddr v)))
  210.      (case r
  211.         (0 (list 'car v))
  212.         (1 (list 'cadr v))
  213.         (2 (list 'caddr v))
  214.         (3 (list 'cadddr v))
  215.         )))
  216.  
  217. (defun dm-nth-cdr (n v)
  218.   (multiple-value-bind (q r) (floor n 4)
  219.      (dotimes (i q) (setq v (list 'cddddr v)))
  220.      (case r
  221.         (0 v)
  222.         (1 (list 'cdr v))
  223.         (2 (list 'cddr v))
  224.         (3 (list 'cdddr v))
  225.         )))
  226.  
  227. (defun dm-bad-key (key)
  228.        (error "Defmacro-lambda-list contains illegal use of ~s." key))
  229.  
  230. (defun dm-too-few-arguments ()
  231.        (error "Too few arguments are supplied to defmacro-lambda-list."))
  232.  
  233. (defun dm-too-many-arguments ()
  234.        (error "Too many arguments are supplied to defmacro-lambda-list."))
  235.  
  236. (defun dm-key-not-allowed (key)
  237.        (error "The key ~s is not allowed." key))
  238.  
  239. (defun find-doc (body ignore-doc)
  240.   (if (endp body)
  241.       (values nil nil nil)
  242.       (let ((d (macroexpand (car body))))
  243.         (cond ((stringp d)
  244.                (if (or (endp (cdr body)) ignore-doc)
  245.                    (values nil nil (cons d (cdr body)))
  246.                    (multiple-value-bind (doc decls b) (find-doc (cdr body) t)
  247.                      (declare (ignore doc))
  248.                      (values d decls b))))
  249.               ((and (consp d) (eq (car d) 'declare))
  250.                (multiple-value-bind (doc decls b)
  251.                                     (find-doc (cdr body) ignore-doc)
  252.                  (values doc (cons d decls) b)))
  253.               (t (values nil nil (cons d (cdr body))))))))
  254.  
  255. (defun find-declarations (body)
  256.   (if (endp body)
  257.       (values nil nil)
  258.       (let ((d (macroexpand (car body))))
  259.         (cond ((stringp d)
  260.                (if (endp (cdr body))
  261.                    (values nil (list d))
  262.                    (multiple-value-bind (ds b)
  263.                        (find-declarations (cdr body))
  264.                      (values (cons d ds) b))))
  265.               ((and (consp d) (eq (car d) 'declare))
  266.                (multiple-value-bind (ds b)
  267.                    (find-declarations (cdr body))
  268.                  (values (cons d ds) b)))
  269.               (t
  270.                (values nil (cons d (cdr body))))))))
  271.  
  272.